Logistic GAMs for Classification

knitr::opts_chunk$set(echo = TRUE,dpi = 400)

Classifying purchasing behavior

library(mgcv)

## Loading required package: nlme

## Warning: package 'nlme' was built under R version 3.6.2

## This is mgcv 1.8-31. For overview type 'help("mgcv-package")'.

csale <- readRDS("csale.rds")

# Examine the csale data frame
head(csale)

str(csale)

## Classes 'tbl_df', 'tbl' and 'data.frame':    1779 obs. of  8 variables:
##  $ purchase         : num  0 0 0 0 0 0 0 0 1 0 ...
##  $ n_acts           : num  11 0 6 8 8 1 5 0 9 18 ...
##  $ bal_crdt_ratio   : num  0 36.1 17.6 12.5 59.1 ...
##  $ avg_prem_balance : num  2494 2494 2494 2494 2494 ...
##  $ retail_crdt_ratio: num  0 11.5 0 0.8 20.8 ...
##  $ avg_fin_balance  : num  1767 1767 0 1021 797 ...
##  $ mortgage_age     : num  182 139 139 139 93 ...
##  $ cred_limit       : num  12500 0 0 0 0 0 0 0 11500 16000 ...

# Fit a logistic model
log_mod <- gam(purchase ~ s(mortgage_age), data = csale,
               family = binomial,
               method = "REML")

# Calculate the probability at the mean
plogis(coef(log_mod))

##       (Intercept) s(mortgage_age).1 s(mortgage_age).2 s(mortgage_age).3 
##         0.2072950         0.5606807         0.7590564         0.5339771 
## s(mortgage_age).4 s(mortgage_age).5 s(mortgage_age).6 s(mortgage_age).7 
##         0.6313451         0.4315829         0.4079339         0.5625195 
## s(mortgage_age).8 s(mortgage_age).9 
##         0.9634169         0.3712867

Purchase behavior with multiple smooths

formula = as.formula(paste0("purchase ~ ",paste0("s(",colnames(csale)[2:ncol(csale)],")",collapse=" + ")))

# Fit a logistic model
log_mod2 <- gam(formula = formula,
                data = csale,
                family = binomial,
                method = "REML")

# View the summary
summary(log_mod2)

## 
## Family: binomial 
## Link function: logit 
## 
## Formula:
## purchase ~ s(n_acts) + s(bal_crdt_ratio) + s(avg_prem_balance) + 
##     s(retail_crdt_ratio) + s(avg_fin_balance) + s(mortgage_age) + 
##     s(cred_limit)
## 
## Parametric coefficients:
##             Estimate Std. Error z value Pr(>|z|)    
## (Intercept) -1.64060    0.07557  -21.71   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Approximate significance of smooth terms:
##                        edf Ref.df Chi.sq  p-value    
## s(n_acts)            3.474  4.310 93.670  < 2e-16 ***
## s(bal_crdt_ratio)    4.308  5.257 18.386  0.00318 ** 
## s(avg_prem_balance)  2.275  2.816  7.800  0.04958 *  
## s(retail_crdt_ratio) 1.001  1.001  1.422  0.23343    
## s(avg_fin_balance)   1.850  2.202  2.506  0.27895    
## s(mortgage_age)      4.669  5.710  9.656  0.13401    
## s(cred_limit)        1.001  1.002 23.066 1.58e-06 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## R-sq.(adj) =  0.184   Deviance explained = 18.4%
## -REML = 781.37  Scale est. = 1         n = 1779

Visualising influences on purchasing probability

set.seed(0)
log_mod2 <- gam(purchase ~ s(n_acts) + s(bal_crdt_ratio) +
                  s(avg_prem_balance) + s(retail_crdt_ratio) +
                  s(avg_fin_balance)  + s(mortgage_age) + s(cred_limit),
                data = csale,
                family = binomial,
                method = "REML")

# Plot on the log-odds scale
plot(log_mod2, pages = 1)

plot(log_mod2, pages = 1, trans = plogis)

plot(log_mod2, pages = 1, trans = plogis,
     shift = coef(log_mod2)[1])

# Plot with intercept uncertainty
plot(log_mod2, pages = 1, trans = plogis,
     shift = coef(log_mod2)[1], seWithMean = T)

Predicting purchasing behavior and uncertainty

new_credit_data <- readRDS("new_credit_data.rds")
log_mod2 <- gam(purchase ~ s(n_acts) + s(bal_crdt_ratio) +
                  s(avg_prem_balance) + s(retail_crdt_ratio) +
                  s(avg_fin_balance)  + s(mortgage_age) + s(cred_limit),
                data = csale,
                family = binomial,
                method = "REML")

# Calculate predictions and errors
predictions <- predict(log_mod2, newdata = new_credit_data,
                       type = "link", se.fit = T)

# Inspect the predictions
predictions

## $fit
##         1         2         3         4         5         6         7 
## -1.301155  0.772986 -2.913542 -2.913542 -2.263154 -1.277517 -1.339294 
## 
## $se.fit
##         1         2         3         4         5         6         7 
## 0.2157911 0.3149660 0.1646090 0.1646090 0.1770119 0.3924700 0.1786229

# Calculate high and low prediction intervals
high_pred <- predictions$fit + predictions$se.fit
low_pred <- predictions$fit - predictions$se.fit

# Convert intervals to probability scale
high_prob <- plogis(high_pred)
low_prob <- plogis(low_pred)

# Inspect
high_prob

##          1          2          3          4          5          6          7 
## 0.25249228 0.74799587 0.06014694 0.06014694 0.11045101 0.29213299 0.23854530

low_prob

##          1          2          3          4          5          6          7 
## 0.17991165 0.61254436 0.04401756 0.04401756 0.08016065 0.15842590 0.17976842

Explaining individual behaviors

log_mod2 <- gam(purchase ~ s(n_acts) + s(bal_crdt_ratio) +
                  s(avg_prem_balance) + s(retail_crdt_ratio) +
                  s(avg_fin_balance)  + s(mortgage_age) + s(cred_limit),
                data = csale,
                family = binomial,
                method = "REML")

# Predict from the model
prediction_1 <- predict(log_mod2,
                        newdata = new_credit_data,
                        type = "terms")

# Inspect
prediction_1

##    s(n_acts) s(bal_crdt_ratio) s(avg_prem_balance) s(retail_crdt_ratio)
## 1 -0.3626621        0.33525205          0.36950597         -0.007532527
## 2  1.8221395        0.36655349          0.07893092          0.067899489
## 3 -0.8850186       -0.40588190         -0.13592053         -0.007532527
## 4 -0.8850186       -0.40588190         -0.13592053         -0.007532527
## 5 -0.6228781       -0.01763481         -0.13592053         -0.007532527
## 6  0.5693622       -0.41095678          0.32942053          0.067899489
## 7 -0.1078251        0.39117226         -0.13592053         -0.007532527
##   s(avg_fin_balance) s(mortgage_age) s(cred_limit)
## 1        -0.04057249     -0.17744840     0.2229033
## 2         0.13456166      0.19538844    -0.2518867
## 3        -0.04057249     -0.02091843     0.2229033
## 4        -0.04057249     -0.02091843     0.2229033
## 5        -0.04057249     -0.02091843     0.2229033
## 6         0.15606041      0.08355615    -0.4322582
## 7        -0.04057249     -0.02091843     0.2229033
## attr(,"constant")
## (Intercept) 
##   -1.640601